home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / nexttsrc.lha / nexttsources / sources / sys / vax_float.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  2.8 KB  |  75 lines
  1. (herald vax_float (env tsys))
  2.  
  3.  
  4. ;;; Flonum dismemberment.
  5.  
  6. ;;; Returns sign, and normalized mantissa and exponent  
  7. ;;; PRECISION is number of bits desired in the mantissa 
  8. ;;; EXCESS is the exponent excess
  9. ;;; HIDDEN-BIT-IS-1.? is true if the hidden bit preceeds the
  10. ;;;  binary point (it does in Apollo IEEE, does not on the VAX).
  11.  
  12. (define (normalize-float-parts sign m e precision excess hidden-bit-is-1.?)
  13.   (let* ((have (integer-length m))
  14.          (need (fx- precision have))
  15.          (normalized-m (%ash m need))
  16.          (normalized-e (- (+ e 
  17.                              precision 
  18.                              excess
  19.                              (if hidden-bit-is-1.? -1 0))
  20.                            need)))
  21.      (return (if (= sign 1) 0 1) normalized-m normalized-e)))
  22.  
  23. ;;; <n,s> means bit field of length s beginning at bit n of the first
  24. ;;; WORD (not longword)
  25. ;;;                    sign      exponent   MSB       fraction
  26. ;;; VAX11 flonum (D)   <15,1>    <7,8>      hidden    <0,7>+next 3 words
  27. ;;; VAX11 flonum (D)   - binary point precedes hidden MSB, 56 bits of
  28. ;;;     precision, if hidden bit is included 
  29.  
  30. (define-constant %%vax-d-size 56)
  31. (define-constant %%vax-d-excess 128)
  32.  
  33. (define (integer-decode-float x)
  34.   (let ((a (mref-16-u x 0)))
  35.     (return (if (fl<= 0.0 x) 1 -1)
  36.             (+ (mref-16-u x 6)
  37.                (%ash (+ (mref-16-u x 4)
  38.                         (%ash (fx+ (mref-16-u x 2)
  39.                                    (fixnum-ashl (fx+ (fixnum-bit-field a 0 7) 128)
  40.                                                 16))
  41.                               16))
  42.                      16))
  43.             (fx- (fixnum-bit-field a 7 8) (fx+ 128 56)))))                      
  44.  
  45. (define (integer-encode-float sign m e)
  46.   (let ((float (make-flonum)))
  47.     (receive (sign mantissa exponent)
  48.              (normalize-float-parts sign
  49.                                     m
  50.                                     e
  51.                                     %%vax-d-size
  52.                                     %%vax-d-excess 
  53.                                     '#f)
  54.       (set (mref-16-u float 0) (fx+ (fixnum-ashl sign 15)
  55.                                     (fx+ (fixnum-ashl exponent 7)
  56.                                          (bignum-bit-field mantissa 48 7))))
  57.       (set (mref-16-u float 2) (bignum-bit-field mantissa 32 16)) 
  58.       (set (mref-16-u float 4) (bignum-bit-field mantissa 16 16)) 
  59.       (set (mref-16-u float 6) (bignum-bit-field mantissa 0  16)) 
  60.       float)))
  61.  
  62. (define (string->flonum s)
  63.   (kludgy-string->flonum s))
  64.  
  65. (lset *print-flonums-kludgily?* t)
  66.  
  67. (define-handler double-float
  68.   (object nil
  69.     ((extended-number-type self) %%flonum-number-type)
  70.     ((print self stream)
  71.      (if *print-flonums-kludgily?*
  72.          (print-flonum-kludgily self stream)
  73.          (print-flonum self stream)))))
  74.                                                
  75.